home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / new-kcl-wrapper.text < prev    next >
Encoding:
Text File  |  1992-07-06  |  58.2 KB  |  2,158 lines
  1. The new-kcl-wrapper modifications make the storage of standard-objects
  2. and structure objects much more similar than before.  These changes should 
  3. greatly speed up WRAPPER-OF for structure objects and should speed up
  4. WRAPPER-OF for standard-instances also (but not funcallable instances).
  5.  
  6. Look first at the defstructs defined here (scan this file for "(defstruct (").
  7. Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of
  8. the wrapper structure.  Finally, look in low.lisp, at the 
  9. "#+new-structure-wrapper" for the definition of %allocate-instance--class.
  10.  
  11. You need to have akcl-1-615 to use this file.
  12.  
  13. This file contains new versions of the files V/c/structure.c and 
  14. V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, 
  15. cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp.
  16.  
  17. -- The gbc changes allow the garbage collector to work correctly even when
  18. structures which define other structures (ones which can be the value of 
  19. STRUCTURE-DEF) are not allocated in static storage. 
  20.  
  21.  
  22. c/gbc.c
  23. *** c/gbc.c       Tue Jun 30 04:11:00 1992
  24. --- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992
  25. ***************
  26. *** 427,453 ****
  27.                           break;
  28.                   goto COPY_STRING;
  29.   
  30.           case t_structure:
  31.                   mark_object(x->str.str_def);
  32.                   p = x->str.str_self;
  33.                   if (p == NULL)
  34. !                         break;
  35. !                 {object def=x->str.str_def;
  36. !                  unsigned char * s_type = &SLOT_TYPE(def,0);
  37. !                  unsigned short *s_pos= & SLOT_POS(def,0);
  38. !                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
  39.                      if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
  40.                    if ((int)what_to_collect >= (int)t_contiguous) {
  41.                        if (inheap(x->str.str_self)) {
  42.                          if (what_to_collect == t_contiguous)
  43.                            mark_contblock((char *)p,
  44. !                                         S_DATA(def)->size);
  45.   
  46.                        } else
  47. !                        x->str.str_self = (object *)
  48. !                          copy_relblock((char *)p, S_DATA(def)->size);
  49.                      }}
  50.                   break;
  51.   
  52.           case t_stream:
  53.                   switch (x->sm.sm_mode) {
  54. --- 427,461 ----
  55.                           break;
  56.                   goto COPY_STRING;
  57.   
  58.           case t_structure:
  59. +                 x->d.m = 2; 
  60.                   mark_object(x->str.str_def);
  61.                   p = x->str.str_self;
  62.                   if (p == NULL)
  63. !                         {x->d.m = TRUE; break;}
  64. !                 {object def=x->str.str_def;
  65. !                  struct s_data *sdef=S_DATA(def);
  66. !                  unsigned char *s_type;
  67. !                  unsigned short *s_pos;
  68. !                  if((int)what_to_collect >= (int)t_contiguous &&
  69. !                     !inheap(sdef) && def->d.m==TRUE)
  70. !                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
  71. !                  s_type = sdef->raw->ust.ust_self;
  72. !                  s_pos = &USHORT(sdef->slot_position,0);
  73. !                  for (i = 0, j = sdef->length;  i < j;  i++)
  74.                      if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
  75.                    if ((int)what_to_collect >= (int)t_contiguous) {
  76.                        if (inheap(x->str.str_self)) {
  77.                          if (what_to_collect == t_contiguous)
  78.                            mark_contblock((char *)p,
  79. !                                         sdef->size);
  80.   
  81.                        } else
  82. !                         x->str.str_self = (object *)
  83. !                          copy_relblock((char *)p, sdef->size);
  84.                      }}
  85. +                 x->d.m = TRUE; 
  86.                   break;
  87.   
  88.           case t_stream:
  89.                   switch (x->sm.sm_mode) {
  90. *** c/sgbc.c      Mon Jun 15 21:16:01 1992
  91. --- akcl-1-615/c/sgbc.c   Wed Jul  1 18:37:24 1992
  92. ***************
  93. *** 355,386 ****
  94.                   if (cp == NULL)
  95.                           break;
  96.                   goto COPY_STRING;
  97.   
  98.           case t_structure:
  99.                   sgc_mark_object(x->str.str_def);
  100.                   p = x->str.str_self;
  101.                   if (p == NULL)
  102. !                         break;
  103. !                 {object def=x->str.str_def;
  104. !                  unsigned char * s_type = &SLOT_TYPE(def,0);
  105. !                  unsigned short *s_pos= & SLOT_POS(def,0);
  106. !                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
  107.                      if (s_type[i]==0 &&
  108.                          ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
  109.                          )
  110.                        sgc_mark_object(STREF(object,x,s_pos[i]));
  111.                    if ((int)what_to_collect >= (int)t_contiguous) {
  112.                        if (inheap(x->str.str_self)) {
  113.                          if (what_to_collect == t_contiguous)
  114.                            mark_contblock((char *)p,
  115. !                                         S_DATA(def)->size);
  116.   
  117.                        } else if(SGC_RELBLOCK_P(p))
  118.                          x->str.str_self = (object *)
  119. !                          copy_relblock((char *)p, S_DATA(def)->size);
  120.                      }}
  121.                   break;
  122.   
  123.           case t_stream:
  124.                   switch (x->sm.sm_mode) {
  125.                   case smm_input:
  126. --- 355,394 ----
  127.                   if (cp == NULL)
  128.                           break;
  129.                   goto COPY_STRING;
  130.   
  131.           case t_structure:
  132. +                 x->d.m = 2;
  133.                   sgc_mark_object(x->str.str_def);
  134.                   p = x->str.str_self;
  135.                   if (p == NULL)
  136. !                         {x->d.m = TRUE; break;}
  137. !                 {object def=x->str.str_def;
  138. !                  struct s_data *sdef=S_DATA(def);
  139. !                  unsigned char *s_type;
  140. !                  unsigned short *s_pos;
  141. !                  if((int)what_to_collect >= (int)t_contiguous &&
  142. !                     !inheap(sdef) && def->d.m==TRUE)
  143. !                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
  144. !                  s_type = sdef->raw->ust.ust_self;
  145. !                  s_pos = &USHORT(sdef->slot_position,0);
  146. !                  for (i = 0, j = sdef->length;  i < j;  i++)
  147.                      if (s_type[i]==0 &&
  148.                          ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
  149.                          )
  150.                        sgc_mark_object(STREF(object,x,s_pos[i]));
  151.                    if ((int)what_to_collect >= (int)t_contiguous) {
  152.                        if (inheap(x->str.str_self)) {
  153.                          if (what_to_collect == t_contiguous)
  154.                            mark_contblock((char *)p,
  155. !                                         sdef->size);
  156.   
  157.                        } else if(SGC_RELBLOCK_P(p))
  158.                          x->str.str_self = (object *)
  159. !                          copy_relblock((char *)p, sdef->size);
  160.                      }}
  161. +                 x->d.m = TRUE; 
  162.                   break;
  163.   
  164.           case t_stream:
  165.                   switch (x->sm.sm_mode) {
  166.                   case smm_input:
  167. cmpnew/cmpinit.lsp
  168. *** cmpnew/cmpinit.lsp    Tue Jun 30 04:11:13 1992
  169. --- ../akcl-1-615/cmpnew/cmpinit.lsp      Mon Jun 22 18:41:51 1992
  170. ***************
  171. *** 4,7 ****
  172. --- 4,10 ----
  173.   (load "sys-proclaim.lisp")
  174.   (setq compiler::*eval-when-defaults* '(compile eval load))
  175.   
  176.   ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel          cmpeval))   (load (format nil "~(~a~).lsp" v)))
  177. + (unless (get 'si::basic-wrapper 'si::s-data)
  178. +   (setf (get 'si::s-data 'si::s-data) nil)
  179. +   (load "../lsp/defstruct.lsp"))
  180. lsp/cmpinit.lsp
  181. *** lsp/cmpinit.lsp       Tue Jun 30 04:11:26 1992
  182. --- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992
  183. ***************
  184. *** 5,12 ****
  185.   (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
  186.   ;(or (get 'si::s-data 'si::s-data)
  187.   ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
  188.   (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
  189. ! 
  190. ! 
  191.   
  192.   ;;;;;
  193. --- 5,13 ----
  194.   (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
  195.   ;(or (get 'si::s-data 'si::s-data)
  196.   ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
  197.   (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
  198. ! (unless (get 'si::basic-wrapper 'si::s-data)
  199. !   (setf (get 'si::s-data 'si::s-data) nil)
  200. !   (load "../lsp/defstruct.lsp"))
  201.   
  202.   ;;;;;
  203. lsp/describe.lsp
  204. *** lsp/describe.lsp      Tue Jun 30 04:11:27 1992
  205. --- ../akcl-1-615/lsp/describe.lsp        Tue Jun 23 16:39:07 1992
  206. ***************
  207. *** 266,282 ****
  208.   
  209.   (defun inspect-structure (x &aux name)
  210.     (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
  211.             (setq name (type-of x)))
  212. !   (let* ((sd (get name 'si::s-data))
  213.            (spos (s-data-slot-position sd)))
  214.       (dolist (v (s-data-slot-descriptions sd))
  215.               (format t "~%~4d:~@[[~s] ~]~20a:~s"   
  216. !                     (aref spos (nth 4 v))
  217. !                     (let ((type (nth 2 v)))
  218.                         (if (eq t type) nil type))
  219. !                     (car v)
  220. !                     (structure-ref1 x (nth 4 v))))))
  221.       
  222.     
  223.   (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
  224.     (inspect-indent)
  225. --- 266,282 ----
  226.   
  227.   (defun inspect-structure (x &aux name)
  228.     (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
  229.             (setq name (type-of x)))
  230. !   (let* ((sd (structure-def x))
  231.            (spos (s-data-slot-position sd)))
  232.       (dolist (v (s-data-slot-descriptions sd))
  233.               (format t "~%~4d:~@[[~s] ~]~20a:~s"   
  234. !                     (aref spos (slot-offset v))
  235. !                     (let ((type (slot-type v)))
  236.                         (if (eq t type) nil type))
  237. !                     (slot-name v)
  238. !                     (structure-ref1 x (slot-offset v))))))
  239.       
  240.     
  241.   (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
  242.     (inspect-indent)
  243. ==============================================================================
  244. =============================== c/structure.c ================================
  245. Changes file for /kcl/c/structure.c
  246. Usage \n@s[Original text\n@s|Replacement Text\n@s]
  247. See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
  248. for a program to merge change files.  Anything not between
  249.  "\n@s[" and  "\n@s]" is a simply a comment.
  250. This file was constructed using emacs and  merge.el
  251.  by (Bill Schelter)  wfs@carl.ma.utexas.edu 
  252.  
  253.  
  254. ****Change:(orig (15 17 d))
  255. @s[object siSstructure_print_function;
  256. object siSstructure_slot_descriptions;
  257. object siSstructure_include;
  258.  
  259. @s|
  260. @s]
  261.  
  262.  
  263. ****Change:(orig (18 18 a))
  264. @s[
  265.  
  266. @s|
  267. #define COERCE_DEF(x) if (type_of(x)==t_symbol) \
  268.   x=getf(x->s.s_plist,siLs_data,Cnil)
  269.  
  270. #define check_type_structure(x) \
  271.   if(type_of((x))!=t_structure) \
  272.     FEwrong_type_argument(Sstructure,(x)) 
  273.  
  274.  
  275.  
  276. @s]
  277.  
  278.  
  279. ****Change:(orig (22 31 c))
  280. @s[{
  281.     do {
  282.         if (type_of(x) != t_symbol)
  283.                 return(FALSE);
  284.  
  285. @s,       } while (x != Cnil);
  286.     return(FALSE);
  287. }
  288.  
  289. @s|{ if (x==y) return 1;
  290.   if (type_of(x)!= t_structure
  291.       || type_of(y)!=t_structure)
  292.     FEerror("bad call to structure_subtypep",0);
  293.   {if (S_DATA(y)->included == Cnil) return 0;
  294.    while ((x=S_DATA(x)->includes) != Cnil)
  295.      { if (x==y) return 1;}
  296.    return 0;
  297.  }}
  298.  
  299. @s]
  300.  
  301.  
  302. ****Change:(orig (32 32 a))
  303. @s[
  304.  
  305. @s|
  306. static
  307. bad_raw_type()
  308. {           FEerror("Bad raw struct type",0);}
  309.  
  310.  
  311.  
  312. @s]
  313.  
  314.  
  315. ****Change:(orig (34 34 c))
  316. @s[structure_ref(x, name, n)
  317.  
  318. @s|structure_ref(x, name, i)
  319.  
  320. @s]
  321.  
  322.  
  323. ****Change:(orig (36 38 c))
  324. @s[object x, name;
  325. int n;
  326. {
  327.     int i;
  328.  
  329. @s|object x, name;
  330. int i;
  331. {unsigned short *s_pos;
  332.  COERCE_DEF(name);
  333.  if (type_of(x) != t_structure ||
  334.      (type_of(name)!=t_structure) ||
  335.      !structure_subtypep(x->str.str_def, name))
  336.    FEwrong_type_argument((type_of(name)==t_structure ?
  337.                   S_DATA(name)->name : name),
  338.                  x);
  339.  s_pos = &SLOT_POS(x->str.str_def,0);
  340.  switch((SLOT_TYPE(x->str.str_def,i)))
  341.    {
  342.    case aet_object: return(STREF(object,x,s_pos[i]));
  343.    case aet_fix:  return(make_fixnum((STREF(int,x,s_pos[i]))));
  344.    case aet_ch:  return(code_char(STREF(char,x,s_pos[i])));
  345.    case aet_bit:
  346.    case aet_char: return(make_fixnum(STREF(char,x,s_pos[i])));
  347.    case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
  348.    case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
  349.    case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i])));
  350.    case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
  351.    case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
  352.    default:
  353.      bad_raw_type();
  354.      return 0;
  355.    }}
  356.  
  357. @s]
  358.  
  359.  
  360. ****Change:(orig (40 43 c))
  361. @s[       if (type_of(x) != t_structure ||
  362.         !structure_subtypep(x->str.str_name, name))
  363.         FEwrong_type_argument(name, x);
  364.     return(x->str.str_self[n]);
  365.  
  366. @s|
  367. void
  368. siLstructure_ref1()
  369. {object x=vs_base[0];
  370.  int n=fix(vs_base[1]);
  371.  object def;
  372.  check_type_structure(x);
  373.  def=x->str.str_def;
  374.  if(n>= S_DATA(def)->length)
  375.    FEerror("Structure ref out of bounds",0);
  376.  vs_base[0]=structure_ref(x,x->str.str_def,n);
  377.  vs_top=vs_base+1;
  378.  
  379. @s]
  380.  
  381.  
  382. ****Change:(orig (45 45 a))
  383. @s[}
  384.  
  385.  
  386. @s|}
  387.  
  388. void
  389. siLstructure_set1()
  390. {object x=vs_base[0];
  391.  int n=fix(vs_base[1]);
  392.  object v=vs_base[2];
  393.  object def;
  394.  check_type_structure(x);
  395.  def=x->str.str_def;
  396.  if(n>= S_DATA(def)->length)
  397.    FEerror("Structure ref out of bounds",0);
  398.  vs_base[0]=structure_set(x,x->str.str_def,n,v);
  399.  vs_top=vs_base+1;
  400. }  
  401.  
  402.  
  403.  
  404. @s]
  405.  
  406.  
  407. ****Change:(orig (47 47 c))
  408. @s[structure_set(x, name, n, v)
  409.  
  410. @s|structure_set(x, name, i, v)
  411.  
  412. @s]
  413.  
  414.  
  415. ****Change:(orig (49 51 c))
  416. @s[object x, name, v;
  417. int n;
  418. {
  419.     int i;
  420.  
  421. @s|object x, name, v;
  422. int i;
  423. {unsigned short *s_pos;
  424.  
  425.  COERCE_DEF(name);
  426.  if (type_of(x) != t_structure ||
  427.      type_of(name) != t_structure ||
  428.      !structure_subtypep(x->str.str_def, name))
  429.    FEwrong_type_argument((type_of(name)==t_structure ?
  430.                   S_DATA(name)->name : name)
  431.                  , x);
  432.  
  433. @s]
  434.  
  435.  
  436. ****Change:(orig (53 57 c))
  437. @s[       if (type_of(x) != t_structure ||
  438.         !structure_subtypep(x->str.str_name, name))
  439.         FEwrong_type_argument(name, x);
  440.     x->str.str_self[n] = v;
  441.  
  442. @s,       return(v);
  443.  
  444. @s|#ifdef SGC
  445.  /* make sure the structure header is on a writable page */
  446.  if (x->d.m) FEerror("bad gc field",0); else  x->d.m = 0;
  447. #endif   
  448.  
  449.  s_pos= & SLOT_POS(x->str.str_def,0);
  450.  switch(SLOT_TYPE(x->str.str_def,i)){
  451.    
  452.    case aet_object: STREF(object,x,s_pos[i])=v; break;
  453.    case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
  454.    case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
  455.    case aet_bit:
  456.    case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
  457.    case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
  458.    case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
  459.    case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
  460.    case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
  461.    case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
  462.  default:
  463.    bad_raw_type();
  464.  
  465.    }
  466.  return(v);
  467.  
  468. @s]
  469.  
  470.  
  471. ****Change:(orig (59 59 a))
  472. @s[}
  473.  
  474.  
  475. @s|}
  476.  
  477. void
  478. siLstructure_subtype_p()
  479. {object x,y;
  480.  check_arg(2);
  481.  x=vs_base[0];
  482.  y=vs_base[1];
  483.  if (type_of(x)!=t_structure)
  484.    {vs_base[0]=Cnil; goto BOTTOM;}
  485.  x=x->str.str_def;
  486.  COERCE_DEF(y);
  487.  if (structure_subtypep(x,y)) vs_base[0]=Ct;
  488.  else vs_base[0]=Cnil;
  489.  BOTTOM:
  490.  vs_top=vs_base+1;
  491. }
  492.  
  493. static object
  494. slot_name(x)
  495.      object x;
  496. {
  497.   if(type_of(x)==t_cons)
  498.     return car(x);
  499.   if(type_of(x)==t_structure)
  500.     return x->str.str_self[0];
  501.   return Cnil;
  502. }
  503.  
  504.  
  505. @s]
  506.  
  507.  
  508. ****Change:(orig (64 64 a))
  509. @s[object x;
  510. {
  511.     object *p, s;
  512.  
  513. @s|object x;
  514. {
  515.     object *p, s;
  516.     struct s_data *def=S_DATA(x->str.str_def);
  517.  
  518. @s]
  519.  
  520.  
  521. ****Change:(orig (66 69 c))
  522. @s[
  523.     s = getf(x->str.str_name->s.s_plist,
  524.              siSstructure_slot_descriptions, Cnil);
  525.     vs_push(x->str.str_name);
  526.  
  527. @s|       
  528.     s = def->slot_descriptions;
  529.     vs_push(def->name);
  530.  
  531. @s]
  532.  
  533.  
  534. ****Change:(orig (72 73 c))
  535. @s[       for (i=0, n=x->str.str_length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
  536.         *p = make_cons(car(s->c.c_car), Cnil);
  537.  
  538. @s|       for (i=0, n=def->length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
  539.         *p = make_cons(slot_name(s->c.c_car), Cnil);
  540.  
  541. @s]
  542.  
  543.  
  544. ****Change:(orig (75 75 c))
  545. @s[               *p = make_cons(x->str.str_self[i], Cnil);
  546.  
  547. @s|               *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil);
  548.  
  549. @s]
  550.  
  551.  
  552. ****Change:(orig (81 81 a))
  553. @s[       stack_cons();
  554.     return(vs_pop);
  555. }
  556.  
  557.  
  558. @s|       stack_cons();
  559.     return(vs_pop);
  560. }
  561.  
  562. void
  563.  
  564. @s]
  565.  
  566.  
  567. ****Change:(orig (84 85 c))
  568. @s[       object x;
  569.     int narg, i;
  570.  
  571. @s|  object x,name,*base;
  572.   struct s_data *def;
  573.   int narg, i,size;
  574.   base=vs_base;
  575.   if ((narg = vs_top - base) == 0)
  576.     too_few_arguments();
  577.   x = alloc_object(t_structure);
  578.   name=base[0];
  579.   COERCE_DEF(name);
  580.   if (type_of(name)!=t_structure  ||
  581.       (def=S_DATA(name))->length != --narg)
  582.     FEerror("Bad make_structure args for type ~a",1,
  583.         base[0]);
  584.   x->str.str_def = name;
  585.   x->str.str_self = NULL;
  586.   size=S_DATA(name)->size;
  587.   base[0] = x;
  588.   x->str.str_self = (object *)
  589.     (def->staticp == Cnil ? alloc_relblock(size)
  590.      : alloc_contblock(size));
  591.   /* There may be holes in the structure.
  592.      We want them zero, so that equal can work better.
  593.      */
  594.   if (S_DATA(name)->has_holes != Cnil)
  595.     bzero(x->str.str_self,size);
  596.   {unsigned char *s_type;
  597.    unsigned short *s_pos;
  598.    s_pos= (&SLOT_POS(x->str.str_def,0));
  599.    s_type = (&(SLOT_TYPE(x->str.str_def,0)));
  600.    base=base+1;
  601.    for (i = 0;  i < narg;  i++)
  602.      {object v=base[i];
  603.       switch(s_type[i]){
  604.          
  605.       case aet_object: STREF(object,x,s_pos[i])=v; break;
  606.       case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
  607.       case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
  608.       case aet_bit:
  609.       case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
  610.       case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
  611.       case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
  612.       case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
  613.       case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
  614.       case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
  615.       default:
  616.     bad_raw_type();
  617.  
  618. @s]
  619.  
  620.  
  621. ****Change:(orig (87 97 c))
  622. @s[       if ((narg = vs_top - vs_base) == 0)
  623.         too_few_arguments();
  624.     x = alloc_object(t_structure);
  625.     x->str.str_name = vs_base[0];
  626.  
  627. @s,               x->str.str_self[i] = vs_top[i];
  628.  
  629. @s|      }}
  630.    vs_top = base;
  631.    vs_base=base-1;
  632.  
  633.  }
  634.  
  635. @s]
  636.  
  637.  
  638. ****Change:(orig (99 99 a))
  639. @s[}
  640.  
  641.  
  642. @s|}
  643.  
  644. void
  645.  
  646. @s]
  647.  
  648.  
  649. ****Change:(orig (103 103 c))
  650. @s[       object x, y;
  651.     int i, j;
  652.  
  653. @s|       object x, y;
  654.     struct s_data *def;
  655.  
  656. @s]
  657.  
  658.  
  659. ****Change:(orig (105 105 c))
  660. @s[
  661.     check_arg(2);
  662.  
  663. @s|
  664.     if (vs_top-vs_base < 1) too_few_arguments();
  665.  
  666. @s]
  667.  
  668.  
  669. ****Change:(orig (107 110 c))
  670. @s[       if (type_of(x) != t_structure || x->str.str_name != vs_base[1])
  671.         FEwrong_type_argument(vs_base[1], x);
  672.     vs_base[1] = y = alloc_object(t_structure);
  673.     y->str.str_name = x->str.str_name;
  674.  
  675. @s|       check_type_structure(x);
  676.     vs_base[0] = y = alloc_object(t_structure);
  677.     def=S_DATA(y->str.str_def = x->str.str_def);
  678.  
  679. @s]
  680.  
  681.  
  682. ****Change:(orig (112 116 c))
  683. @s[       y->str.str_length = j = x->str.str_length;
  684.     y->str.str_self = (object *)alloc_relblock(sizeof(object)*j);
  685.     for (i = 0;  i < j;  i++)
  686.         y->str.str_self[i] = x->str.str_self[i];
  687.  
  688. @s,       vs_base++;
  689.  
  690. @s|       y->str.str_self = (object *)alloc_relblock(def->size);
  691.     bcopy(x->str.str_self,y->str.str_self,def->size);
  692.     vs_top=vs_base+1;
  693.  
  694. @s]
  695.  
  696.  
  697. ****Change:(orig (118 118 a))
  698. @s[}
  699.  
  700.  
  701. @s|}
  702.  
  703. void
  704. siLcopy_structure_header()
  705. {
  706.     object x, y;
  707.  
  708.     if (vs_top-vs_base < 1) too_few_arguments();
  709.     x = vs_base[0];
  710.     check_type_structure(x);
  711.     vs_base[0] = y = alloc_object(t_structure);
  712.     y->str.str_def = x->str.str_def;
  713.     y->str.str_self = x->str.str_self;
  714.     vs_top=vs_base+1;
  715. }
  716.  
  717.  
  718. void
  719.  
  720. @s]
  721.  
  722.  
  723. ****Change:(orig (122 124 c))
  724. @s[       if (type_of(vs_base[0]) != t_structure)
  725.         FEwrong_type_argument(Sstructure, vs_base[0]);
  726.     vs_base[0] = vs_base[0]->str.str_name;
  727.  
  728. @s|       check_type_structure(vs_base[0]);
  729.     vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;
  730.  
  731. @s]
  732.  
  733.  
  734. ****Change:(orig (127 127 c))
  735. @s[}
  736.  
  737. siLstructure_ref()
  738.  
  739. @s|}
  740.  
  741. #define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \
  742.                      structure_slot_position(str,name))
  743.  
  744. object
  745. structure_ref_new(x, name, i)
  746.      object x,name,i;
  747.  
  748. @s]
  749.  
  750.  
  751. ****Change:(orig (129 131 c))
  752. @s[       object x;
  753.     int i;
  754.     check_arg(3);
  755.  
  756. @s|  return structure_ref(x,name,FIND_SLOT(x,i));
  757. }
  758.  
  759. @s]
  760.  
  761.  
  762. ****Change:(orig (133 144 c))
  763. @s[       x = vs_base[0];
  764.     if (type_of(x) != t_structure ||
  765.         !structure_subtypep(x->str.str_name, vs_base[1]))
  766.         FEwrong_type_argument(vs_base[1], x);
  767.  
  768. @s,       vs_base[0] = x->str.str_self[i];
  769.     vs_top = vs_base+1;
  770.  
  771. @s|object
  772. structure_set_new(x, name, i, v)
  773.      object x,name,i,v;
  774. {
  775.   return structure_set(x,name,FIND_SLOT(x,i),v);
  776.  
  777. @s]
  778.  
  779.  
  780. ****Change:(orig (146 146 a))
  781. @s[}
  782.  
  783.  
  784. @s|}
  785.  
  786. void
  787. siLstructure_ref()
  788. {
  789.   check_arg(3);
  790.   vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]);
  791.   vs_top=vs_base+1;
  792. }
  793.  
  794. void
  795.  
  796. @s]
  797.  
  798.  
  799. ****Change:(orig (149 150 d))
  800. @s[siLstructure_set()
  801. {
  802.     object x;
  803.     int i;
  804.  
  805. @s|siLstructure_set()
  806. {
  807.  
  808. @s]
  809.  
  810.  
  811. ****Change:(orig (152 163 c))
  812. @s[
  813.     x = vs_base[0];
  814.     if (type_of(x) != t_structure ||
  815.         !structure_subtypep(x->str.str_name, vs_base[1]))
  816.  
  817. @s,       x->str.str_self[i] = vs_base[3];
  818.  
  819. @s|       structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]);
  820.  
  821. @s]
  822.  
  823.  
  824. ****Change:(orig (166 166 a))
  825. @s[       vs_base = vs_top-1;
  826. }
  827.  
  828.  
  829. @s|       vs_base = vs_top-1;
  830. }
  831.  
  832. void
  833.  
  834. @s]
  835.  
  836.  
  837. ****Change:(orig (228 228 c))
  838. @s[init_structure_function()
  839.  
  840. @s|void
  841. siLmake_s_data_structure()
  842. {object x,y,raw,*base;
  843.  int i;
  844.  check_arg(5);
  845.  x=vs_base[0];
  846.  base=vs_base;
  847.  raw=vs_base[1];
  848.  y=alloc_object(t_structure);
  849.  y->str.str_def=y;
  850.  y->str.str_self = (object *)( x->v.v_self);
  851.  S_DATA(y)->name  =siLs_data;
  852.  S_DATA(y)->length=(raw->v.v_dim);
  853.  S_DATA(y)->raw   =raw;
  854.  for(i=3; i<raw->v.v_dim; i++)
  855.    y->str.str_self[i]=Cnil;
  856.  S_DATA(y)->slot_position=base[2];
  857.  S_DATA(y)->slot_descriptions=base[3];
  858.  S_DATA(y)->staticp=base[4];
  859.  S_DATA(y)->size = (raw->v.v_dim)*sizeof(object);
  860.  vs_base[0]=y;
  861.  vs_top=vs_base+1;
  862. }
  863.  
  864. object siSstructure_init,siSstructure_init_named;
  865. object siSname,siSdefault_init;
  866. object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions;
  867.  
  868. static object
  869. slot_value(str,name)
  870.      object str,name;
  871.  
  872. @s]
  873.  
  874.  
  875. ****Change:(orig (230 237 c))
  876. @s[       siSstructure_print_function
  877.     = make_si_ordinary("STRUCTURE-PRINT-FUNCTION");
  878.     enter_mark_origin(&siSstructure_print_function);
  879.     siSstructure_slot_descriptions
  880.  
  881. @s,       enter_mark_origin(&siSstructure_include);
  882.  
  883. @s| top:
  884.   if(type_of(str)==t_structure)
  885.     return structure_ref_new(str,str->str.str_def,name);
  886.   if(str->c.c_car==siSstructure_init_named)
  887.     {object new=get(str->c.c_cdr,siLs_data);
  888.      str->c.c_car=siSstructure_init;
  889.      str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
  890.   if(siSstructure_init!=car(str))
  891.     FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0);
  892.   {object key=intern(coerce_to_string(name),keyword_package);
  893.    object value=getf(cdddr(str),key,NULL);
  894.    if(value!=NULL)
  895.      return value;
  896.    else
  897.      {object slots;
  898.       if(str==caddr(str)&&name==siSslot_descriptions)
  899.     FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0);
  900.       slots=slot_value(caddr(str),siSslot_descriptions);
  901.       for(;!endp(slots);slots=cdr(slots))
  902.     if(name==slot_value(car(slots),siSname))
  903.       {object result,form=slot_value(car(slots),siSdefault_init);
  904.        object *old_vs_base=vs_base,*old_vs_top=vs_top;
  905.        vs_base=vs_top;vs_push(form);Leval();result=vs_base[0];
  906.        vs_base=old_vs_base; vs_top=old_vs_top;
  907.        return result;}
  908.       FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}}
  909.   return Cnil;
  910. }
  911.  
  912. @s]
  913.  
  914.  
  915. ****Change:(orig (238 238 a))
  916. @s[
  917.  
  918. @s|
  919. int 
  920. structure_slot_position(str,name)
  921.      object str,name;
  922. {
  923.   if(type_of(name)==t_fixnum)
  924.     return fix(name);
  925.   else
  926.     {object slotd_list;
  927.      int pos;
  928.      check_type_structure(str);
  929.      slotd_list=S_DATA(str->str.str_def)->slot_descriptions;
  930.      for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list))
  931.        {object slotd=car(slotd_list);
  932.     if(name==((type_of(slotd)==t_structure)?
  933.           slotd->str.str_self[0]:slot_value(slotd,siSname)))
  934.       return pos;}
  935.      FEerror("Slot ~S not found in structure ~S",2,name,str);
  936.      return 0;}  
  937. }
  938.  
  939. static object
  940. make_structures_internal(value)
  941.      object value;
  942. {
  943.   object str,def;
  944.   int def_index,i,ind;
  945.  
  946.   switch(type_of(value))
  947.     {case t_cons:
  948.        if(value->c.c_car==siSstructure_init_named)
  949.      {object new=get(value->c.c_cdr,siLs_data);
  950.       value->c.c_car=siSstructure_init;
  951.       value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
  952.        if(car(value)!=siSstructure_init)
  953.      {value->c.c_car=make_structures_internal(value->c.c_car);
  954.       value->c.c_cdr=make_structures_internal(value->c.c_cdr);
  955.       break;}
  956.        if(type_of(cadr(value))==t_structure)
  957.      {value=value->c.c_cdr->c.c_car;
  958.       break;}
  959.        {object def=caddr(value),plist=cdddr(value),result;
  960.     object slots,slots_tail;
  961.     int size,staticp,len,i;
  962.     if(def!=value)def=make_structures_internal(def);
  963.     result=alloc_object(t_structure);
  964.     result->str.str_def=(def==value)?result:def;
  965.     result->str.str_self=NULL;
  966.     value->c.c_cdr->c.c_car=result;
  967.     size=fixint(slot_value(def,siSsize));
  968.     staticp=Cnil!=slot_value(def,siSstaticp);
  969.     slots=slot_value(def,siSslot_descriptions);
  970.     len=length(slots);
  971.     result->str.str_self=(object *)(staticp?alloc_contblock(size):
  972.                                         alloc_relblock(size));
  973.     bzero(result->str.str_self,size);
  974.     if(def==value)
  975.       {S_DATA(result)->raw=slot_value(def,siSraw);
  976.        S_DATA(result)->slot_position=slot_value(def,siSslot_position);}
  977.     for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
  978.       {object svalue=slot_value(value,slot_value(car(slots_tail),siSname));
  979.        structure_set(result,result->str.str_def,i,svalue);}
  980.     for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
  981.       {object svalue=structure_ref(result,result->str.str_def,i);
  982.        svalue=make_structures_internal(svalue);
  983.        structure_set(result,result->str.str_def,i,svalue);}
  984.     value=result;
  985.     break;}
  986.      case t_vector:
  987.        if ((enum aelttype)value->v.v_elttype == aet_object)
  988.      {int i,len=value->v.v_dim;
  989.       for(i=0; i<len; i++)
  990.         value->v.v_self[i]=make_structures_internal(value->v.v_self[i]);}
  991.        break;
  992.      case t_symbol:
  993.        {object plist=value->s.s_plist,next;
  994.     for(;!endp(plist);plist=cddr(plist))
  995.       {next=plist->c.c_cdr;
  996.        if(plist->c.c_car==siLs_data&&
  997.           type_of(next->c.c_car)==t_cons)
  998.          next->c.c_car=make_structures_internal(next->c.c_car);}
  999.     break;}}
  1000.   return value;   
  1001. }
  1002.  
  1003. void
  1004. siLmake_structures()
  1005. {
  1006.   check_arg(1);
  1007.   vs_base[0]=make_structures_internal(vs_base[0]);
  1008. }
  1009.  
  1010. void
  1011. siLstructure_def()
  1012. {check_arg(1);
  1013.  check_type_structure(vs_base[0]);
  1014.   vs_base[0]=vs_base[0]->str.str_def;
  1015. }
  1016.  
  1017. short aet_sizes [] = {
  1018. sizeof(object),  /* aet_object  t  */
  1019. sizeof(char),  /* aet_ch  string-char  */
  1020. sizeof(char),  /* aet_bit  bit  */
  1021. sizeof(fixnum),  /* aet_fix  fixnum  */
  1022. sizeof(float),  /* aet_sf  short-float  */
  1023. sizeof(double),  /* aet_lf  long-float  */
  1024. sizeof(char),  /* aet_char  signed char */
  1025. sizeof(char),  /* aet_uchar  unsigned char */
  1026. sizeof(short),  /* aet_short  signed short */
  1027. sizeof(short)  /* aet_ushort  unsigned short   */
  1028. };
  1029.  
  1030.   
  1031.  
  1032.  
  1033.  
  1034. void
  1035. siLsize_of() 
  1036. { object x= vs_base[0];
  1037.   int i;
  1038.   i= aet_sizes[get_aelttype(x)];
  1039.   vs_base[0]=make_fixnum(i);
  1040. }
  1041.   
  1042. void
  1043. siLaet_type()
  1044. {vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));}
  1045.  
  1046.  
  1047. /* Return N such that something of type ARG can be aligned on
  1048.    an address which is a multiple of N */
  1049.  
  1050.  
  1051. void
  1052. siLalignment()
  1053. {struct {double x; int y; double z;
  1054.      float x1; int y1; float z1;}
  1055.  joe;
  1056.  joe.z=3.0;
  1057.  
  1058.  if (vs_base[0]==Slong_float)
  1059.    {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;}
  1060.  else
  1061.    if (vs_base[0]==Sshort_float)
  1062.      {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;}
  1063.    else
  1064.      {siLsize_of();}
  1065. }
  1066.    
  1067. void
  1068. swap_structure_contents(str1,str2)
  1069.    object str1,str2;
  1070. {
  1071.   object def1,*self1;
  1072.   check_type_structure(str1);
  1073.   check_type_structure(str2);
  1074.   def1=str1->str.str_def;
  1075.   self1=str1->str.str_self;
  1076.   str1->str.str_def=str2->str.str_def;
  1077.   str1->str.str_self=str2->str.str_self;
  1078.   str2->str.str_def=def1;
  1079.   str2->str.str_self=self1;
  1080. }
  1081.  
  1082. void
  1083. siLswap_structure_contents()
  1084. {
  1085.   check_arg(2);
  1086.   swap_structure_contents(vs_base[0],vs_base[1]);
  1087.   vs_base[0]=Cnil;
  1088.   vs_top=vs_base+1;
  1089. }
  1090.  
  1091. void
  1092. siLset_structure_def()
  1093. {check_arg(2);
  1094.  check_type_structure(vs_base[0]);
  1095.  check_type_structure(vs_base[1]);
  1096.  vs_base[0]->str.str_def=vs_base[1];
  1097.  vs_base[0]=vs_base[1];
  1098.  vs_top=vs_base+1;
  1099. }
  1100.  
  1101. init_structure_function()
  1102. {
  1103.         siLs_data=make_si_ordinary("S-DATA");
  1104.     siSstructure_init=make_si_ordinary("STRUCTURE-INIT");
  1105.     siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED");
  1106.     siSname=make_si_ordinary("NAME");
  1107.     siSdefault_init=make_si_ordinary("DEFAULT-INIT");
  1108.     siSraw=make_si_ordinary("RAW");
  1109.     siSslot_position=make_si_ordinary("SLOT-POSITION");
  1110.     siSsize=make_si_ordinary("SIZE");
  1111.     siSstaticp=make_si_ordinary("STATICP");
  1112.     siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS");
  1113.  
  1114. @s]
  1115.  
  1116.  
  1117. ****Change:(orig (239 239 a))
  1118. @s[       make_si_function("MAKE-STRUCTURE", siLmake_structure);
  1119.  
  1120. @s|       make_si_function("MAKE-STRUCTURE", siLmake_structure);
  1121.     make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure);
  1122.  
  1123. @s]
  1124.  
  1125.  
  1126. ****Change:(orig (240 240 a))
  1127. @s[       make_si_function("COPY-STRUCTURE", siLcopy_structure);
  1128.  
  1129. @s|       make_si_function("COPY-STRUCTURE", siLcopy_structure);
  1130.     make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header);
  1131.  
  1132. @s]
  1133.  
  1134.  
  1135. ****Change:(orig (242 242 a))
  1136. @s[       make_si_function("STRUCTURE-REF", siLstructure_ref);
  1137.  
  1138. @s|       make_si_function("STRUCTURE-REF", siLstructure_ref);
  1139.     make_si_function("STRUCTURE-DEF", siLstructure_def);
  1140.     make_si_function("STRUCTURE-REF1", siLstructure_ref1);
  1141.     make_si_function("STRUCTURE-SET1", siLstructure_set1);
  1142.  
  1143. @s]
  1144.  
  1145.  
  1146. ****Change:(orig (245 245 c))
  1147. @s[       make_si_function("STRUCTUREP", siLstructurep);
  1148.  
  1149.  
  1150. @s|       make_si_function("STRUCTUREP", siLstructurep);
  1151.     make_si_function("SIZE-OF", siLsize_of);
  1152.     make_si_function("ALIGNMENT",siLalignment);
  1153.     make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p);
  1154.  
  1155. @s]
  1156.  
  1157.  
  1158. ****Change:(orig (247 247 a))
  1159. @s[       make_si_function("LIST-NTH", siLlist_nth);
  1160.  
  1161. @s|       make_si_function("LIST-NTH", siLlist_nth);
  1162.     make_si_function("AET-TYPE",siLaet_type);
  1163.     make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents);
  1164.     make_si_function("SET-STRUCTURE-DEF", siLset_structure_def);
  1165.     make_si_function("MAKE-STRUCTURES", siLmake_structures);
  1166.  
  1167.  
  1168. @s]
  1169.  
  1170. ==============================================================================
  1171. ============================== V/lsp/defstruct.lsp =============================
  1172. Changes file for /kcl/lsp/defstruct.lsp
  1173. Usage \n@s[Original text\n@s|Replacement Text\n@s]
  1174. See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
  1175. for a program to merge change files.  Anything not between
  1176.  "\n@s[" and  "\n@s]" is a simply a comment.
  1177. This file was constructed using emacs and  merge.el
  1178.  by (Bill Schelter)  wfs@carl.ma.utexas.edu 
  1179.  
  1180.  
  1181. ****Change:(orig (20 71 c))
  1182. @s[(defun make-access-function (name conc-name type named
  1183.                              slot-name default-init slot-type read-only
  1184.                              offset)
  1185.   (declare (ignore named default-init slot-type))
  1186.  
  1187. @s,          ((error "~S is an illegal structure type." type)))))
  1188.  
  1189. @s|(defvar *accessors* (make-array 10 :adjustable t))
  1190. (defvar *list-accessors* (make-array 2 :adjustable t))
  1191. (defvar *vector-accessors* (make-array 2 :adjustable t))
  1192.  
  1193. @s]
  1194.  
  1195.  
  1196. ****Change:(orig (72 72 a))
  1197. @s[
  1198.  
  1199. @s|
  1200. (or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
  1201.                        #'(lambda (&rest l) l nil)))
  1202.  
  1203. @s]
  1204.  
  1205.  
  1206. ****Change:(orig (73 73 a))
  1207. @s[
  1208.  
  1209. @s|
  1210. (defun boot-slot-value (str name)
  1211.   (if (structurep str)
  1212.       (structure-ref str (structure-def str) name)
  1213.       (getf (cdddr str) (intern (string name) :keyword))))
  1214.  
  1215. (defun boot-set-slot-value (str name new-value)
  1216.   (if (structurep str)
  1217.       (structure-set str (structure-def str) name new-value)
  1218.       (setf (getf (cdddr str) (intern (string name) :keyword)) new-value)))
  1219.  
  1220. (defun boot-subtypep (type1 type2)
  1221.   (or (eq type1 type2)
  1222.       (let* ((s-data (get type1 's-data))
  1223.          (include (boot-s-data-name (boot-slot-value s-data 'includes))))
  1224.     (boot-subtypep include type2))))
  1225.  
  1226. (defun make-slot-boot (&rest args)
  1227.   (if (get 's-data 's-data)
  1228.       (apply #'make-slot args)
  1229.       (list* 'structure-init
  1230.          nil
  1231.          '(structure-init-named . slot)
  1232.          args)))
  1233.  
  1234. (defun make-s-data-boot (&rest args)
  1235.   (if (get 's-data 's-data)
  1236.       (apply #'make-s-data args)
  1237.       (list* 'structure-init
  1238.          nil
  1239.          '(structure-init-named . s-data)
  1240.          args)))
  1241.  
  1242. (defun make-boot-accessor (slot accessor)
  1243.   (setf (symbol-function accessor) 
  1244.     #'(lambda (object)
  1245.         (boot-slot-value object slot)))
  1246.   (let ((writer (intern (format nil "SET ~A" accessor))))
  1247.     (setf (symbol-function writer)
  1248.       #'(lambda (object value)
  1249.           (boot-set-slot-value object slot value)))
  1250.     (eval `(defsetf ,accessor ,writer))))
  1251.  
  1252. (defmacro defstructboot (name &rest slots)
  1253.   (let ((conc-name (if (listp name)
  1254.                (string (second (assoc :conc-name (cdr name))))
  1255.                (format nil "~A-" name))))
  1256.     `(progn
  1257.        ,@(mapcar #'(lambda (slot)
  1258.              (let ((fname (intern (format nil "~A~A" conc-name slot))))
  1259.                `(make-boot-accessor ',slot ',fname)))
  1260.              slots))))
  1261.  
  1262. (defstructboot (slot (:conc-name boot-slot-))
  1263.   name default-init type read-only offset accessor-name type-changed)
  1264.  
  1265. (defstructboot (s-data-internal (:conc-name boot-s-data-))
  1266.   name length raw included includes staticp print-function
  1267.   slot-descriptions slot-position size has-holes)
  1268.  
  1269. (defstructboot (basic-wrapper (:conc-name boot-wrapper-))
  1270.   cache-number-vector state class)
  1271.  
  1272. (defstructboot (s-data (:conc-name boot-s-data-))
  1273.   frozen documentation constructors offset
  1274.   named type conc-name)
  1275.  
  1276. (defun make-access-function (name conc-name type named include no-fun slot)
  1277.   (declare (ignore named))
  1278.   
  1279.   (let* ((slot-name (boot-slot-name slot))
  1280.      (slot-type (boot-slot-type slot))
  1281.      (read-only (boot-slot-read-only slot))
  1282.      (offset (boot-slot-offset slot))
  1283.      (access-function
  1284.       (intern (si:string-concatenate (string conc-name)
  1285.                                  (string slot-name))))
  1286.     accsrs dont-overwrite)
  1287.     (unless (boot-slot-accessor-name slot)
  1288.       (setf (boot-slot-accessor-name slot) access-function))
  1289.     (ecase type
  1290.       ((nil)
  1291.        (setf accsrs *accessors*))
  1292.       (list
  1293.     (setf accsrs *list-accessors*))
  1294.       (vector
  1295.     (setf accsrs *vector-accessors*)))
  1296.     (or (> (length  accsrs) offset)
  1297.     (adjust-array accsrs (+ offset 10)))
  1298.     (unless
  1299.      dont-overwrite
  1300.      (record-fn access-function 'defun '(t) slot-type)
  1301.      (or no-fun
  1302.      (and (fboundp access-function)
  1303.           (eq (aref accsrs offset) (symbol-function access-function)))
  1304.      (setf (symbol-function access-function)
  1305.        (or (aref accsrs offset)
  1306.            (setf (aref accsrs offset)
  1307.              (cond  ((eq accsrs *accessors*)
  1308.                         #'(lambda (x)
  1309.                             (or (structurep x)
  1310.                                 (error "~a is not a structure" x))
  1311.                             (structure-ref1 x offset)))
  1312.                        ((eq accsrs *list-accessors*)
  1313.                         #'(lambda(x)
  1314.                             (si:list-nth offset x)))
  1315.                        ((eq accsrs *vector-accessors*)
  1316.                         #'(lambda(x)
  1317.                             (aref x offset)))))))))
  1318.     (cond (read-only
  1319.         (remprop access-function 'structure-access)
  1320.         (setf (get access-function 'struct-read-only) t))
  1321.       (t (remprop access-function 'setf-update-fn)
  1322.          (remprop access-function 'setf-lambda)
  1323.          (remprop access-function 'setf-documentation)
  1324.          (let ((tem (get access-function 'structure-access)))
  1325.            (cond ((and (consp tem) include
  1326.                    (if (consp (get include 's-data))
  1327.                        (boot-subtypep include (car tem))
  1328.                        (subtypep include (car tem)))
  1329.                    (eql (cdr tem) offset))
  1330.               ;; don't change overwrite accessor of subtype.
  1331.               (setq dont-overwrite t)
  1332.               )
  1333.              (t  (setf (get access-function 'structure-access)
  1334.                        (cons (if type type name) offset)))))))
  1335.     nil))
  1336.  
  1337.  
  1338. @s]
  1339.  
  1340.  
  1341. ****Change:(orig (80 89 c))
  1342. @s[                     (cond ((null x)
  1343.                             ;; If the slot-description is NIL,
  1344.                             ;;  it is in the padding of initial-offset.
  1345.                             nil)
  1346.  
  1347. @s,                           (t (car x))))
  1348.  
  1349. @s|                    (or (boot-slot-name x)
  1350.                  (and (boot-slot-default-init x)
  1351.                       ;; If the slot name is NIL,
  1352.                       ;;  it is the structure name.
  1353.                       ;;  This is for typed structures with names.
  1354.                       (list 'quote (boot-slot-default-init x)))))
  1355.  
  1356. @s]
  1357.  
  1358.  
  1359. ****Change:(orig (94 97 c))
  1360. @s[                     (cond ((null x) nil)
  1361.                            ((null (car x)) nil)
  1362.                            ((null (cadr x)) (list (car x)))
  1363.                            (t (list (list  (car x) (cadr x))))))
  1364.  
  1365. @s|                    (when (boot-slot-name x)
  1366.                (if (boot-slot-default-init x)
  1367.                    (list (list (boot-slot-name x) (boot-slot-default-init x)))
  1368.                    (list (boot-slot-name x)))))
  1369.  
  1370. @s]
  1371.  
  1372.  
  1373. ****Change:(orig (248 248 d))
  1374. @s[          ((error "~S is an illegal structure type" type)))))
  1375.  
  1376.  
  1377.  
  1378. @s|          ((error "~S is an illegal structure type" type)))))
  1379.  
  1380.  
  1381. @s]
  1382.  
  1383.  
  1384. ****Change:(orig (252 265 d))
  1385. @s[
  1386. (defun make-copier (name copier type named)
  1387.   (declare (ignore named))
  1388.   (cond ((null type)
  1389.  
  1390. @s,        ((error "~S is an illegal structure type." type))))
  1391.  
  1392.  
  1393.  
  1394. @s|
  1395. @s]
  1396.  
  1397.  
  1398. ****Change:(orig (267 275 c))
  1399. @s[  (cond ((null type)
  1400.          ;; If TYPE is NIL, the predicate searches the link
  1401.          ;;  of structure-include, until there is no included structure.
  1402.          `(defun ,predicate (x)
  1403.  
  1404. @s,                   (setq n (get n 'structure-include))))))
  1405.  
  1406. @s|  (cond ((null type))
  1407.      ; done in define-structure
  1408.  
  1409. @s]
  1410.  
  1411.  
  1412. ****Change:(orig (282 283 c))
  1413. @s[                 (> (length x) ,name-offset)
  1414.                  (eq (elt x ,name-offset) ',name))))
  1415.  
  1416. @s|                 (> (the fixnum (length x)) ,name-offset)
  1417.                  (eq (aref (the (vector t) x) ,name-offset) ',name))))
  1418.  
  1419. @s]
  1420.  
  1421.  
  1422. ****Change:(orig (294 294 a))
  1423. @s[                         ((= i 0) (and (consp y) (eq (car y) ',name)))
  1424.  
  1425. @s|                         ((= i 0) (and (consp y) (eq (car y) ',name)))
  1426.                  (declare (fixnum i))
  1427.  
  1428. @s]
  1429.  
  1430.  
  1431. ****Change:(orig (300 301 c))
  1432. @s[;;;  and returns a list of the form:
  1433. ;;;        (slot-name default-init slot-type read-only offset)
  1434.  
  1435. @s|;;;  and returns a slot.
  1436.  
  1437. @s]
  1438.  
  1439.  
  1440. ****Change:(orig (325 325 c))
  1441. @s[    (list slot-name default-init slot-type read-only offset)))
  1442.  
  1443. @s|    (make-slot-boot :name slot-name
  1444.             :default-init default-init
  1445.             :type slot-type
  1446.             :read-only read-only
  1447.             :offset offset)))
  1448.  
  1449. @s]
  1450.  
  1451.  
  1452. ****Change:(orig (335 335 c))
  1453. @s[      (let ((sds (member (caar olds) news :key #'car)))
  1454.  
  1455. @s|      (let* ((old (car olds))
  1456.          (sds (member (boot-slot-name old) news :key #'slot-name))
  1457.          (new (car sds)))
  1458.  
  1459. @s]
  1460.  
  1461.  
  1462. ****Change:(orig (337 348 c))
  1463. @s[               (when (and (null (cadddr (car sds)))
  1464.                           (cadddr (car olds)))
  1465.                      ;; If read-only is true in the old
  1466.                      ;;  and false in the new, signal an error.
  1467.  
  1468. @s,                           (car (cddddr (car olds))))
  1469.  
  1470. @s|               (when (and (null (boot-slot-read-only new))
  1471.                           (boot-slot-read-only old))
  1472.          ;; If read-only is true in the old
  1473.          ;;  and false in the new, signal an error.
  1474.          (error "~S is an illegal include slot-description."
  1475.                 new))
  1476.            ;; If
  1477.            (setf (boot-slot-type new)
  1478.              (best-array-element-type (boot-slot-type new)))
  1479.            (when (not (equal (normalize-type (or (boot-slot-type new) t))
  1480.                          (normalize-type (or (boot-slot-type old) t))))
  1481.          (error "Type mismmatch for included slot ~a" new))
  1482.            (cons (make-slot :name (boot-slot-name new)
  1483.                         :default-init (boot-slot-default-init new)
  1484.                         :type (boot-slot-type new)
  1485.                         :read-only (boot-slot-read-only new)
  1486.                         :offset (boot-slot-offset old))
  1487.  
  1488. @s]
  1489.  
  1490.  
  1491. ****Change:(orig (353 353 a))
  1492. @s[                     (overwrite-slot-descriptions news (cdr olds))))))))
  1493.  
  1494.  
  1495. @s|                     (overwrite-slot-descriptions news (cdr olds))))))))
  1496.  
  1497. (defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))
  1498.  
  1499. @s]
  1500.  
  1501.  
  1502. ****Change:(orig (355 355 c))
  1503. @s[;;; The DEFSTRUCT macro.
  1504.  
  1505. @s|(defun make-t-type (n include slot-descriptions &aux i)
  1506.   (let ((res  (make-array n :element-type 'unsigned-char :static t)))
  1507.     (when include
  1508.       (let ((tem (get include 's-data))raw)
  1509.     (or tem (error "Included structure undefined ~a" include))
  1510.     (setq raw (boot-s-data-raw tem))
  1511.     (dotimes (i (min n (length raw)))
  1512.       (setf (aref res i) (aref raw i)))))
  1513.     (dolist (v slot-descriptions)
  1514.       (setq i (boot-slot-offset v))
  1515.       (let ((type (boot-slot-type v)))
  1516.     (cond ((<= (the fixnum (alignment type)) #. (alignment t))
  1517.            (setf (aref res i) (aet-type type))))))
  1518.     (cond ((< n (length *all-t-s-type*))
  1519.        (dotimes (i n)
  1520.          (cond ((not (eql (the fixnum (aref res i)) 0))
  1521.             (return-from make-t-type res))))
  1522.        *all-t-s-type*)
  1523.       (t res))))
  1524.  
  1525. @s]
  1526.  
  1527.  
  1528. ****Change:(orig (356 356 a))
  1529. @s[
  1530.  
  1531. @s|
  1532. (defvar *standard-slot-positions*
  1533.   (let ((ar (make-array 50 :element-type 'unsigned-short
  1534.                 :static t))) 
  1535.     (dotimes (i 50)
  1536.          (declare (fixnum i))
  1537.          (setf (aref ar i)(* #. (size-of t) i)))
  1538.     ar))
  1539.  
  1540. (eval-when (compile )
  1541. (proclaim '(function round-up (fixnum fixnum ) fixnum))
  1542. )
  1543.  
  1544. (defun round-up (a b)
  1545.   (declare (fixnum a b))
  1546.   (setq a (ceiling a b))
  1547.   (the fixnum (* a b)))
  1548.  
  1549.  
  1550. (defun get-slot-pos (leng include slot-descriptions &aux type small-types
  1551.                   has-holes) 
  1552.   (declare (special *standard-slot-positions*)) include
  1553.   (dolist (v slot-descriptions)
  1554.     (when (boot-slot-name v)
  1555.       (setf type (best-array-element-type (boot-slot-type v))
  1556.         (boot-slot-type v) type)
  1557.       (let ((val (boot-slot-default-init v)))
  1558.     (unless (typep val type)
  1559.       (if (and (symbolp val)
  1560.            (constantp val))
  1561.           (setf val (symbol-value val)))
  1562.       (and (constantp val)
  1563.            (setf (boot-slot-default-init v) (coerce val type)))))
  1564.       (cond ((memq type '(signed-char unsigned-char
  1565.                   short unsigned-short
  1566.                   long-float
  1567.                   bit))
  1568.          (setq small-types t)))))
  1569.   (cond ((and (null small-types)
  1570.           (< leng (length *standard-slot-positions*))
  1571.           (list  *standard-slot-positions* (* leng #. (size-of t)) nil)))
  1572.     (t (let ((ar (make-array leng :element-type 'unsigned-short
  1573.                          :static t))
  1574.          (pos 0)(i 0)(align 0)type (next-pos 0))
  1575.          (declare (fixnum pos i align next-pos))
  1576.          ;; A default array.
  1577.            
  1578.          (dolist (v slot-descriptions)
  1579.            (setq type (boot-slot-type v))
  1580.            (setq align (alignment type))
  1581.            (unless (<= align #. (alignment t))
  1582.          (setq type t)
  1583.          (setf (boot-slot-type v) t)
  1584.          (setq align #. (alignment t))
  1585.          (setf (boot-slot-type-changed v) t))
  1586.            (setq next-pos (round-up pos align))      
  1587.            (or (eql pos next-pos) (setq has-holes t))
  1588.            (setq pos next-pos)
  1589.            (setf (aref ar i) pos)
  1590.            (incf pos (size-of type))
  1591.            (incf i))
  1592.          (list ar (round-up pos (size-of t)) has-holes)
  1593.          ))))
  1594.  
  1595.  
  1596. (defun define-structure (name conc-name type named slot-descriptions copier
  1597.                       static include print-function constructors
  1598.                       offset predicate &optional documentation no-funs
  1599.                       &aux leng)
  1600.   (and (consp type) (eq (car type) 'vector)(setq type 'vector))
  1601.   (setq leng (length slot-descriptions))
  1602.   (setq slot-descriptions 
  1603.     (mapcar #'(lambda (info)
  1604.             (make-slot-boot :name (first info)
  1605.                             :default-init (second info)
  1606.                             :type (third info)
  1607.                             :read-only (fourth info)
  1608.                             :offset (fifth info)
  1609.                             :accessor-name (sixth info)
  1610.                             :type-changed (seventh info)))
  1611.         slot-descriptions))
  1612.   (dolist (x slot-descriptions)
  1613.     (when (boot-slot-name x)
  1614.       (make-access-function name conc-name type named include no-funs x)))
  1615.   (when (and copier (not no-funs))
  1616.     (setf (symbol-function copier)
  1617.       (ecase type
  1618.         ((nil) #'si::copy-structure)
  1619.         (list #'copy-list)
  1620.         (vector #'copy-seq))))
  1621.   (let ((include-str (and include (get include 's-data))))
  1622.     (when (and (eq include 's-data-internal)
  1623.            (not (eq name 'basic-wrapper)))
  1624.       (error "only ~s can include ~s" 'basic-wrapper 's-data-internal))
  1625.     (when include-str
  1626.       (cond ((and (not (consp include-str))
  1627.           (s-data-frozen include-str)
  1628.           (or (not (s-data-included include-str))
  1629.               (not (let ((te (get name 's-data)))
  1630.                      (and te
  1631.                           (eq (s-data-includes te)
  1632.                               include-str))))))
  1633.          (warn " ~a was frozen but now included"
  1634.            include)))
  1635.       (let ((old-included (boot-slot-value include-str 'included)))
  1636.     (unless (member name old-included)
  1637.       (boot-set-slot-value include-str 'included (cons name old-included)))))
  1638.     (let* ((tem (get name 's-data))
  1639.        (g-s-p (and (null type)
  1640.                (get-slot-pos leng include slot-descriptions)))
  1641.        (slot-position (car g-s-p))
  1642.        (size (if g-s-p (cadr g-s-p) 0))
  1643.        (has-holes (caddr g-s-p))
  1644.        (def (make-s-data-boot :name name
  1645.                           :length leng
  1646.                           :raw
  1647.                           (and (null type)
  1648.                                (make-t-type leng include 
  1649.                                             slot-descriptions))
  1650.                           :slot-position slot-position
  1651.                           :size size
  1652.                           :has-holes has-holes
  1653.                           :staticp static
  1654.                           :includes include-str
  1655.                           :print-function print-function
  1656.                           :slot-descriptions slot-descriptions
  1657.                           :constructors constructors
  1658.                           :offset offset
  1659.                           :type type
  1660.                           :named named
  1661.                           :documentation documentation
  1662.                           :conc-name conc-name)))
  1663.       (check-s-data tem def name)
  1664.       (when (and (consp def) (eq name 's-data))
  1665.     (make-structures def))))
  1666.   (when documentation
  1667.     (setf (get name 'structure-documentation)
  1668.       documentation))
  1669.   (when (and  (null type)  predicate)
  1670.     (record-fn predicate 'defun '(t) t)
  1671.     (or no-funs
  1672.     (setf (symbol-function predicate)
  1673.           #'(lambda (x)
  1674.           (si::structure-subtype-p x name))))
  1675.     (setf (get predicate 'compiler::co1)
  1676.       'compiler::co1structure-predicate)
  1677.     (setf (get predicate 'struct-predicate) name))
  1678.   nil)
  1679.  
  1680. (defun check-s-data (old new name)
  1681.   (unless (and old (member name '(slot s-data-internal basic-wrapper s-data)))
  1682.     (when (and old (eq (structure-def old) (get 's-data 's-data)))
  1683.       (boot-set-slot-value new 'included (boot-slot-value old 'included))
  1684.       (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen)))
  1685.     (unless (and old
  1686.          (eq (structure-def old) (get 's-data 's-data))
  1687.          (let ((new-cnv (boot-slot-value new 'cache-number-vector))
  1688.                (old-cnv (boot-slot-value old 'cache-number-vector)))
  1689.            (boot-set-slot-value new 'cache-number-vector old-cnv)
  1690.            (prog1 (equalp new old)
  1691.              (boot-set-slot-value new 'cache-number-vector new-cnv))))
  1692.       (when old
  1693.     (warn "structure ~a is changing" name)
  1694.     (when (eq (structure-def old) (get 's-data 's-data))
  1695.       (boot-set-slot-value old 'state (list ':obsolete new))))
  1696.       (setf (get name 's-data) new))))
  1697.  
  1698.  
  1699. @s]
  1700.  
  1701.  
  1702. ****Change:(orig (364 364 c))
  1703. @s[        predicate predicate-specified
  1704.         include
  1705.  
  1706. @s|        predicate predicate-specified
  1707.         include include-s-data
  1708.  
  1709. @s]
  1710.  
  1711.  
  1712. ****Change:(orig (367 367 c))
  1713. @s[        offset name-offset
  1714.         documentation)
  1715.  
  1716. @s|        offset name-offset
  1717.         documentation
  1718.     static)
  1719.  
  1720. @s]
  1721.  
  1722.  
  1723. ****Change:(orig (370 370 c))
  1724. @s[          ;; The defstruct options are supplied.
  1725.  
  1726. @s|         ;; The defstruct options are supplied.
  1727.  
  1728. @s]
  1729.  
  1730.  
  1731. ****Change:(orig (390 425 c))
  1732. @s[      (cond ((and (consp (car os)) (not (endp (cdar os))))
  1733.              (setq o (caar os) v (cadar os))
  1734.              (case o
  1735.                (:conc-name
  1736.  
  1737. @s,               (t (error "~S is an illegal defstruct option." o))))))
  1738.  
  1739. @s|       (cond ((and (consp (car os)) (not (endp (cdar os))))
  1740.            (setq o (caar os) v (cadar os))
  1741.            (case o
  1742.          (:conc-name
  1743.            (if (null v)
  1744.                (setq conc-name "")
  1745.              (setq conc-name v)))
  1746.          (:constructor
  1747.            (if (null v)
  1748.                (setq no-constructor t)
  1749.              (if (endp (cddar os))
  1750.                  (setq constructors (cons v constructors))
  1751.                (setq constructors (cons (cdar os) constructors)))))
  1752.          (:copier (setq copier v))
  1753.          (:static (setq static v))
  1754.          (:predicate
  1755.            (setq predicate v)
  1756.            (setq predicate-specified t))
  1757.          (:include
  1758.            (setq include (cdar os))
  1759.            (unless (setq include-s-data (get v 's-data))
  1760.                    (error "~S is an illegal included structure." v)))
  1761.          (:print-function
  1762.           (and (consp v) (eq (car v) 'function)
  1763.                (setq v (second v)))
  1764.           (setq print-function v))
  1765.          (:type (setq type v))
  1766.          (:initial-offset (setq initial-offset v))
  1767.          (t (error "~S is an illegal defstruct option." o))))
  1768.           (t
  1769.         (if (consp (car os))
  1770.             (setq o (caar os))
  1771.           (setq o (car os)))
  1772.         (case o
  1773.           (:constructor
  1774.             (setq constructors
  1775.                   (cons default-constructor constructors)))
  1776.           ((:conc-name :copier :predicate :print-function))
  1777.           (:named (setq named t))
  1778.           (t (error "~S is an illegal defstruct option." o))))))
  1779.  
  1780. @s]
  1781.  
  1782.  
  1783. ****Change:(orig (426 426 a))
  1784. @s[
  1785.  
  1786. @s|
  1787.     (setq conc-name (intern (string conc-name)))
  1788.  
  1789.     (and include-s-data (not print-function)
  1790.      (setq print-function (boot-s-data-print-function include-s-data)))
  1791.  
  1792.  
  1793. @s]
  1794.  
  1795.  
  1796. ****Change:(orig (434 435 c))
  1797. @s[    (when include
  1798.           (unless (equal type (get (car include) 'structure-type))
  1799.  
  1800. @s|    (when include-s-data
  1801.           (unless (equal type (boot-s-data-type include-s-data))
  1802.  
  1803. @s]
  1804.  
  1805.  
  1806. ****Change:(orig (442 443 c))
  1807. @s[          (t
  1808.            (setq offset (get (car include) 'structure-offset))))
  1809.  
  1810. @s|          (t 
  1811.         (setq offset (boot-s-data-offset include-s-data))))
  1812.  
  1813. @s]
  1814.  
  1815.  
  1816. ****Change:(orig (457 458 c))
  1817. @s[      (setq sds (cons (parse-slot-description (car ds) offset) sds))
  1818.       (setq offset (1+ offset)))
  1819.  
  1820. @s|       (setq sds (cons (parse-slot-description (car ds) offset) sds))
  1821.     (setq offset (1+ offset)))
  1822.  
  1823. @s]
  1824.  
  1825.  
  1826. ****Change:(orig (464 464 c))
  1827. @s[                (cons (list nil name) slot-descriptions)))
  1828.  
  1829. @s|                (cons (make-slot :default-init name) slot-descriptions)))
  1830.  
  1831. @s]
  1832.  
  1833.  
  1834. ****Change:(orig (469 469 c))
  1835. @s[                (append (make-list initial-offset) slot-descriptions)))
  1836.  
  1837. @s|                (append (mapcar #'make-named-slot (make-list initial-offset))
  1838.                 slot-descriptions)))
  1839.  
  1840. @s]
  1841.  
  1842.  
  1843. ****Change:(orig (473 486 c))
  1844. @s[    (cond ((null include))
  1845.           ((endp (cdr include))
  1846.            (setq slot-descriptions
  1847.                  (append (get (car include) 'structure-slot-descriptions)
  1848.  
  1849. @s,                         slot-descriptions))))
  1850.  
  1851. @s|    (let ((include-slot-descriptions 
  1852.        (and include
  1853.         (boot-s-data-slot-descriptions include-s-data))))
  1854.       (cond ((null include))
  1855.         ((endp (cdr include))
  1856.          (setq slot-descriptions
  1857.            (append include-slot-descriptions
  1858.                    slot-descriptions)))
  1859.         (t
  1860.          (setq slot-descriptions
  1861.            (append (overwrite-slot-descriptions
  1862.                     (mapcar #'(lambda (sd)
  1863.                                 (parse-slot-description sd 0))
  1864.                             (cdr include))
  1865.                     include-slot-descriptions)
  1866.                    slot-descriptions)))))
  1867.  
  1868. @s]
  1869.  
  1870.  
  1871. ****Change:(orig (489 492 c))
  1872. @s[           ;; If a constructor option is NIL,
  1873.            ;;  no constructor should have been specified.
  1874.            (when constructors
  1875.                  (error "Contradictory constructor options.")))
  1876.  
  1877. @s|           ;; If a constructor option is NIL,
  1878.         ;;  no constructor should have been specified.
  1879.         (when constructors
  1880.           (error "Contradictory constructor options.")))
  1881.  
  1882. @s]
  1883.  
  1884.  
  1885. ****Change:(orig (494 495 c))
  1886. @s[           ;; If no constructor is specified,
  1887.            ;;  the default-constructor is made.
  1888.  
  1889. @s|          ;; If no constructor is specified,
  1890.        ;;  the default-constructor is made.
  1891.  
  1892. @s]
  1893.  
  1894.  
  1895. ****Change:(orig (497 497 a))
  1896. @s[           (setq constructors (list default-constructor))))
  1897.  
  1898.  
  1899. @s|           (setq constructors (list default-constructor))))
  1900.  
  1901.     ;; We need a default constructor for the sharp-s-reader
  1902.     (or (member t (mapcar 'symbolp  constructors))
  1903.     (push (intern (string-concatenate "__si::" default-constructor))
  1904.               constructors))
  1905.  
  1906.  
  1907. @s]
  1908.  
  1909.  
  1910. ****Change:(orig (509 509 c))
  1911. @s[          (error "An print function is supplied to a typed structure."))
  1912.  
  1913. @s|          (error "A print function is supplied to a typed structure."))
  1914.     
  1915.     `(progn
  1916.        (define-structure ',name  ',conc-name ',type ',named
  1917.                  ',(mapcar #'(lambda (slotd)
  1918.                                (list (boot-slot-name slotd)
  1919.                                      (boot-slot-default-init slotd)
  1920.                                      (boot-slot-type slotd)
  1921.                                      (boot-slot-read-only slotd)
  1922.                                      (boot-slot-offset slotd)
  1923.                                      (boot-slot-accessor-name slotd)
  1924.                                      (boot-slot-type-changed slotd)))
  1925.                            slot-descriptions)
  1926.                  ',copier ',static ',include ',print-function ',constructors 
  1927.                  ',offset ',predicate ',documentation)
  1928.  
  1929. @s]
  1930.  
  1931.  
  1932. ****Change:(orig (511 542 c))
  1933. @s[    `(progn (si:putprop ',name
  1934.                         '(defstruct ,name ,@slots)
  1935.                         'defstruct-form)
  1936.             (si:putprop ',name t 'is-a-structure)
  1937.  
  1938. @s,            (si:putprop ',name ,documentation 'structure-documentation)
  1939.             ',name)))
  1940.  
  1941. @s|       ,@(mapcar #'(lambda (constructor)
  1942.              (make-constructor name constructor type named
  1943.                                slot-descriptions))
  1944.          constructors)
  1945.        ,@(if (and type predicate)
  1946.          (list (make-predicate name predicate type named
  1947.                            name-offset)))
  1948.        ',name
  1949.        )))
  1950.  
  1951. @s]
  1952.  
  1953.  
  1954. ****Change:(orig (544 544 a))
  1955. @s[
  1956.  
  1957.  
  1958. @s|
  1959.  
  1960. (eval-when (compile load eval)
  1961.  
  1962. (defconstant wrapper-cache-number-adds-ok 4)
  1963.  
  1964. (defconstant wrapper-cache-number-length
  1965.          (- (integer-length most-positive-fixnum)
  1966.         wrapper-cache-number-adds-ok))
  1967.  
  1968. (defconstant wrapper-cache-number-mask
  1969.          (1- (expt 2 wrapper-cache-number-length)))
  1970.  
  1971.  
  1972. (defvar *get-wrapper-cache-number* (make-random-state))
  1973.  
  1974. (defun get-wrapper-cache-number ()
  1975.   (let ((n 0))
  1976.     (declare (fixnum n))
  1977.     (loop
  1978.       (setq n
  1979.         (logand wrapper-cache-number-mask
  1980.             (random most-positive-fixnum *get-wrapper-cache-number*)))
  1981.       (unless (zerop n) (return n)))))
  1982.  
  1983. )
  1984.  
  1985. (eval-when (compile load eval)
  1986.  
  1987. (defconstant wrapper-cache-number-vector-length 8)
  1988.  
  1989. (deftype cache-number-vector ()
  1990.   `(simple-array fixnum (8)))
  1991.  
  1992. (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
  1993.                                :initial-element 'number))
  1994.  
  1995. )
  1996.  
  1997. (defun make-wrapper-cache-number-vector ()
  1998.   (let ((cnv (make-array #.wrapper-cache-number-vector-length
  1999.                  :element-type 'fixnum)))
  2000.     (dotimes (i #.wrapper-cache-number-vector-length)
  2001.       (setf (aref cnv i) (get-wrapper-cache-number)))
  2002.     cnv))
  2003.  
  2004. (defstruct (slot
  2005.          (:static t)
  2006.          (:constructor make-slot)
  2007.          (:constructor make-named-slot (name)))
  2008.   name
  2009.   default-init
  2010.   (type t)
  2011.   read-only
  2012.   offset
  2013.   accessor-name
  2014.   type-changed)
  2015.  
  2016. ;; All of the fields of s-data-internal must coincide with 
  2017. ;; the C structure s_data (see object.h).
  2018. (defstruct (s-data-internal
  2019.          (:conc-name s-data-)
  2020.          (:constructor nil)
  2021.          (:static t))
  2022.   ;; all of these slots are used by c code
  2023.   name                    ; a symbol
  2024.   (length 0 :type fixnum) ; length of slot-descriptions
  2025.   raw                     ; a static array of unsigned-short (enum aelttype)
  2026.   included                ; a list of the names of structures including this one
  2027.   includes                ; nil or a s-data structure
  2028.   staticp         ; t or nil
  2029.   print-function  ; nil, a symbol, or a lambda expression
  2030.   slot-descriptions       ; a list of slots
  2031.   slot-position           ; a static array of unsigned-short
  2032.   (size 0 :type fixnum) ; total size to allocate
  2033.   has-holes)              ; t or nil
  2034.  
  2035. (defstruct (basic-wrapper (:include s-data-internal)
  2036.                   (:conc-name wrapper-)
  2037.                   (:constructor nil)
  2038.                   (:static t))
  2039.   (cache-number-vector (make-wrapper-cache-number-vector))
  2040.   (state t) ;  either t or a list (state-sym new-wrapper)
  2041.   ;;           where state-sym is either :flush or :obsolete
  2042.   (class nil))
  2043.  
  2044. ;(get name 'si::s-data) ;returns one of these:
  2045. (defstruct (s-data (:include basic-wrapper)
  2046.            (:static t))
  2047.   ;; these slots are used only from lisp
  2048.   frozen          ; t or nil ; t means won't include this
  2049.   documentation 
  2050.   constructors            ; a list of either a symbol or a list symbol, arglist
  2051.   offset          ; the total number of slots and placeholders
  2052.   named                   ; t or nil
  2053.   type                    ; one of: nil, list, or vector
  2054.   conc-name)              ; an interned symbol
  2055.  
  2056. #|| 
  2057. (import '(si::wrapper-state si::wrapper-class si::basic-wrapper))
  2058.  
  2059. (defstruct (wrapper (:include basic-wrapper)
  2060.             (:print-function print-wrapper)
  2061.             (:constructor make-wrapper-internal)
  2062.             (:predicate wrapper-p)
  2063.             (:conc-name wrapper-))
  2064.   (class-slots nil :type list))
  2065.  
  2066. (defun print-wrapper (instance stream depth)
  2067.   (printing-random-thing (wrapper stream)
  2068.     (format stream "Wrapper ~S" (wrapper-class wrapper))))
  2069. ||#
  2070.  
  2071. (defun update-wrapper-state (old new same-p)
  2072.   (unless (consp old)
  2073.     (setf (wrapper-state old) 
  2074.       (list (if same-p ':flush ':obsolete) new))))
  2075.  
  2076. (defun freeze-defstruct (name)
  2077.   (let ((tem (and (symbolp name) (get name 's-data))))
  2078.     (if tem (setf (s-data-frozen tem) t))))
  2079.  
  2080.  
  2081.  
  2082. @s]
  2083.  
  2084.  
  2085. ****Change:(orig (551 553 c))
  2086. @s[  (let ((l (read stream)))
  2087.     (unless (get (car l) 'is-a-structure)
  2088.             (error "~S is not a structure." (car l)))
  2089.  
  2090. @s|  (let* ((l (prog1 (read stream t nil t)
  2091.           (if *read-suppress*
  2092.           (return-from sharp-s-reader nil))))
  2093.      (sd
  2094.        (or (get (car l) 's-data)
  2095.            
  2096.            (error "~S is not a structure." (car l)))))
  2097.     
  2098.  
  2099. @s]
  2100.  
  2101.  
  2102. ****Change:(orig (558 558 c))
  2103. @s[         (do ((cs (get (car l) 'structure-constructors) (cdr cs)))
  2104.  
  2105. @s|         (do ((cs (s-data-constructors sd) (cdr cs)))
  2106.  
  2107. @s]
  2108.  
  2109.  
  2110. ****Change:(orig (571 571 d))
  2111. @s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
  2112.  
  2113.  
  2114.  
  2115. @s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
  2116.  
  2117.  
  2118. @s]
  2119.  
  2120.  
  2121. ****Change:(orig (582 582 c))
  2122. @s[(defstruct person name age sex)
  2123.  
  2124. @s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
  2125.                                                 sex)
  2126. (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
  2127.                                                 sex)
  2128. (defstruct person1 name (age 20 :type fixnum)
  2129.                                                 sex)
  2130.  
  2131. @s]
  2132.  
  2133.  
  2134. ****Change:(orig (584 584 c))
  2135. @s[(defstruct (astronaut (:include person (age 45))
  2136.  
  2137. @s|(defstruct joe a (a1 0 :type (mod  30)) (a2 0 :type (mod  30))
  2138.   (a3 0 :type (mod  30)) (a4 0 :type (mod 30)) )
  2139.  
  2140. ;(defstruct person name age sex)
  2141.  
  2142. (defstruct (astronaut (:include person (age 45 :type fixnum))
  2143.  
  2144. @s]
  2145.  
  2146.  
  2147. ****Change:(orig (605 605 a))
  2148. @s[  associative
  2149.   identity)
  2150.  
  2151. @s|  associative
  2152.   identity)
  2153.  
  2154.  
  2155. @s]
  2156.  
  2157. ==============================================================================
  2158.